perm filename DB.LSP[C,JRA]1 blob
sn#012876 filedate 1972-11-15 generic text, type T, neo UTF8
00100 (GLOBAL
00200 (FUNCTIONS IN-CONTEXT OBJECT CFRAME PUSH-CONTEXT POP-CONTEXT
00300 SPLICE FETCHI FETCHM REALIZE UNREALIZE REAL UNREAL
00400 ACTUALIZE UNACTUALIZE DPUTCF DGETCF DREMCF DPUT DGET DREM
00500 DPUT+ DGET+ DREM+ PRESENT ABSENT DATUM MENTIONERS C-MARKER
00600 /!" /!"1 IF-NEEDED IF-ADDED IF-REMOVED DATA-INIT FETCH ADD
00700 REMOVE INSERT KILL FLUSH NEW-CONTEXT PATH)
00800 (RESERVED *CONTEXT DATUM *CFRAME GLOBAL
00900 *OBJECT *POSSIBILITIES CONTEXT *ITEM *METHOD *IGNORE))
01000
01100
01200 (DECLARE (SYMBOLS T) (GENPREFIX \D) (GENSYM 'D)
01300 (SPECIAL CFRAMES CNUM CONTEXT DATUM CMARKERS TYPE PATTERN
01400 GLOBAL INCCON NUMACT NUMCON *CNUM
01500 *IF-ADDEDS *IF-NEEDEDS *IF-REMOVEDS *INDEXTHRESHOLD *ITEMS NEW)
01600 (*FEXPR /!" CDEFUN CERR CSETQ /: /,
01700 GCCON IF-ADDED IF-NEEDED IF-REMOVED)
01800 (*LEXPR BIND ABSENT ADD CEVAL CFRAME CSET VLOC DGET
01900 DGET+ DPUT DPUT+ DREM DREM+ FETCH FETCHI
02000 FETCHM INSERT KILL MATCH NOTE OBJECT POP-CONTEXT PRESENT
02100 DATA-INIT PUSH-CONTEXT REAL REALIZE REMOVE RVALUE UNREAL
02200 UNREALIZE)
02300 (*EXPR ARGS DATUM CMARKERS PATTERN)
02400 (**ARRAY FRAMES RFRAMES))
02500
02600 (SETQ *INDEXTHRESHOLD 10.) (DEFUN OBJECT N
02700 (LIST '*OBJECT (COND ((= N 0) NIL)
02800 ((= N 1) (ARG 1))
02900 ((TMA)) )) )
03000
03100 (DEFUN TMA ()
03200 (CERR TOO MANY ARGUMENTS) )
03300
03400 (DEFUN TFA ()
03500 (CERR TOO FEW ARGUMENTS) )
03600
03700 (DECLARE (UNSPECIAL CMARKERS TYPE))
03800
03900 (DEFUN MAKE-METHOD (TYPE BOD)
04000 (PROG (FIRST OLDM CMARKERS)
04100 (COND ((ATOM (SETQ FIRST (CAR BOD)))
04200 (SETQ CMARKERS
04300 (COND ((SETQ OLDM (GET FIRST 'DATUM))
04400 (CDR (CMARKERS OLDM))) ))
04500 (PUTPROP FIRST
04600 (NCONC (LIST TYPE FIRST (CADR BOD) (CDDR BOD))
04700 CMARKERS)
04800 'DATUM)
04900 (RETURN FIRST))
05000 ((RETURN (LIST TYPE NIL FIRST (CDR BOD)))) ) ))
05100
05200 (DECLARE (SPECIAL CMARKERS TYPE))
05300
05400
05500 (DEFUN IF-NEEDED FEXPR (A)
05600 (MAKE-METHOD 'IF-NEEDED A))
05700
05800
05900 (DEFUN IF-ADDED FEXPR (A)
06000 (MAKE-METHOD 'IF-ADDED A))
06100
06200
06300 (DEFUN IF-REMOVED FEXPR (A)
06400 (MAKE-METHOD 'IF-REMOVED A))
06500
06600
00100 (DEFUN DATA-INIT K
00200 ((LAMBDA (N M)
00300 (PI-OFF)
00400 (COND ((BOUNDP 'NUMACT)
00500 (DO I 0 (ADD1 I) (= I NUMACT)
00600 (DO DATA (CDDR (FRAMES I)) (CDR DATA) (NULL DATA)
00700 ((LAMBDA (D)
00800 (AND (ATOM D) (RPLACD (CMARKERS D) NIL)))
00900 (CAR DATA)) ))))
01000 (SETQ NUMCON N INCCON M)
01100 (ARRAY FRAMES T NUMCON)
01200 (ARRAY RFRAMES T NUMCON)
01300 (STORE (FRAMES 0) (LIST '*CFRAME (SETQ *CNUM 0)))
01400 (STORE (RFRAMES 0) (CDR (FRAMES 0)))
01500 (CSETQ CONTEXT (CSETQ GLOBAL (LIST '*CONTEXT (FRAMES 0))))
01600 (SETQ NUMACT 1)
01700 (PUTPROP 'ITEM (SETQ *ITEMS (LIST '*LIST '(PATTERN THING) 0)) '*INDEX)
01800 (PUTPROP 'IF-NEEDED (SETQ *IF-NEEDEDS (LIST '*LIST '(PATTERN THING) 0)) '*INDEX)
01900 (PUTPROP 'IF-ADDED (SETQ *IF-ADDEDS (LIST '*LIST '(PATTERN THING) 0)) '*INDEX)
02000 (PUTPROP 'IF-REMOVED (SETQ *IF-REMOVEDS (LIST '*LIST '(PATTERN THING) 0)) '*INDEX)
02100 (SSTATUS INTERRUPT 20. 'GCCON)
02200 (PI-ON))
02300 (COND ((> K 0)(ARG 1)) (T 100.))
02400 (COND ((> K 1)(ARG 2)) (T 10.)) ))
00100 (DECLARE (UNSPECIAL PATTERN))
00200
00300 (DEFUN FETCH N
00400 (PROG (PATTERN CON)
00500 (SETQ PATTERN (ARG 1)
00600 CON (GETCONTEXT 1 N))
00700 (RETURN
00800 (CONS (LIST '*POSSIBILITIES PATTERN)
00900 (CONS '*IGNORE
01000 (NCONC (FETCHI1 PATTERN CON)
01100 (FETCHM1 PATTERN *IF-NEEDEDS CON))))) ))
01200
01300
01400
01500 (DEFUN FETCHI N
01600 (CONS (LIST '*POSSIBILITIES (ARG 1))
01700 (CONS '*IGNORE (FETCHI1 (ARG 1) (GETCONTEXT 1 N)))) )
01800
01900
02000 (DEFUN FETCHM N
02100 (COND ((> N 3) (TMA)) )
02200 ((LAMBDA (CON)
02300 (CONS (LIST '*POSSIBILITIES (ARG 1))
02400 (CONS '*IGNORE
02500 (FETCHM1 (ARG 1)
02600 (COND ((< N 2) *IF-NEEDEDS)
02700 ((GET (ARG 2) '*INDEX)) )
02800 CON))) )
02900 (COND ((< N 3) (/, CONTEXT))
03000 ((ARG 3)) )) )
03100
03200
03300 (DEFUN FETCHI1 (PATTERN CON)
03400 (PROG (ALISTS)
03500 (RETURN (MAPCAN '(LAMBDA (ITEM)
03600 (COND ((SETQ ALISTS (MATCH PATTERN (CAR ITEM)))
03700 (LIST (LIST '*ITEM ITEM (CAR ALISTS)))) ))
03800 (SEARCH *ITEMS PATTERN T (CDR CON)))) ))
03900
04000
04100 (DEFUN FETCHM1 (PATTERN INDEX CON)
04200 (MAPCAN '(LAMBDA (METHOD)
04300 ((LAMBDA (MRESULT)
04400 (COND (MRESULT
04500 (LIST (CONS '*METHOD (CONS METHOD (NCONC MRESULT (LIST PATTERN)))))) ))
04600 (MATCH (PATTERN METHOD) PATTERN)))
04700 (SEARCH INDEX PATTERN NIL (CDR CON))) )
04800
04900 (DECLARE (SPECIAL PATTERN))
00100 (DEFUN REAL N (AND (REALITY (ARG 1) (GETCONTEXT 1 N)) (ARG 1)) )
00200
00300
00400 (DEFUN UNREAL N (AND (NOT (REALITY (ARG 1) (GETCONTEXT 1 N))) (ARG 1)) )
00500
00600
00700 (DEFUN PRESENT N
00800 (PROG (CON PAT CANDIDATES ALISTS)
00900 (SETQ PAT (ARG 1)
01000 CON (GETCONTEXT 1 N)
01100 CANDIDATES (SEARCH *ITEMS PAT T (CDR CON)))
01200 LOOP (COND ((NULL CANDIDATES) (RETURN NIL))
01300 ((SETQ ALISTS (MATCH PAT (ITEM (CAR CANDIDATES))))
01400 (MAPC '(LAMBDA (PAIR)
01500 (CSET (CAR PAIR) (CADR PAIR)))
01600 (CAR ALISTS))
01700 (RETURN (CAR CANDIDATES))) )
01800 (SETQ CANDIDATES (CDR CANDIDATES))
01900 (GO LOOP) ))
02000
02100
02200 (DEFUN ABSENT N
02300 (UNREAL (DATUM (ARG 1)) (GETCONTEXT 1 N)) )
00100 (DECLARE (UNSPECIAL PATTERN))
00200
00300 (DEFUN SEARCH (INDEX PATTERN ITEM CON)
00400 (MAPCAN '(LAMBDA (THING)
00500 (COND ((REALITY1 (CDR (CMARKERS THING))
00600 CON)
00700 (LIST THING)) ))
00800 (ISEARCH INDEX PATTERN ITEM)) )
00900
01000 (DECLARE (SPECIAL PATTERN))
01100
01200
01300 (DEFUN REALITY (DATUM CON)
01400 (REALITY1 (CDR (CMARKERS DATUM)) (CDR CON)))
01500
01600
01700 (DEFUN REALITY1 (CMARKERS CFRAMES)
01800 (PROG (CM CON)
01900 (SETQ CON CFRAMES)
02000 LOOP (COND ((SETQ CM (MFINTERSECT))
02100 (OR (INVISIBLE (CADR CM) CON) (RETURN CM))
02200 (SETQ CMARKERS (CDR CMARKERS) CFRAMES (CDR CFRAMES))
02300 (GO LOOP))
02400 ((RETURN NIL)) ) ))
02500
02600
02700 (DEFUN DATUM (SKELETON)
02800 (PROG (CANDIDATES)
02900 (SETQ CANDIDATES (ISEARCH *ITEMS SKELETON T))
03000 LOOP (COND ((NULL CANDIDATES) (RETURN (LIST SKELETON)))
03100 ((EQUAL (ITEM (CAR CANDIDATES)) SKELETON)
03200 (RETURN (CAR CANDIDATES))) )
03300 (SETQ CANDIDATES (CDR CANDIDATES))
03400 (GO LOOP) )) (DEFUN ADD N (REALIZE (DATUMIZE (ARG 1)) (GETCONTEXT 1 N)) )
03500
03600
03700 (CDEFUN ADD (THING "OPTIONAL" (CONTEXT CONTEXT))
03800 (REALIZE (/@ DATUMIZE (/, THING)) CONTEXT) )
03900
04000
04100 (DEFUN REMOVE N (UNREALIZE (DATUMIZE (ARG 1)) (GETCONTEXT 1 N)) )
04200
04300
04400 (CDEFUN REMOVE (THING "OPTIONAL" (CONTEXT CONTEXT))
04500 (UNREALIZE (/@ DATUMIZE (/, THING)) CONTEXT) )
04600
04700
04800 (DEFUN INSERT N
04900 ((LAMBDA (D)
05000 (REVEAL D (GETCONTEXT 1 N)) D)
05100 (DATUMIZE (ARG 1))) )
05200
05300
05400 (DEFUN KILL N
05500 ((LAMBDA (D)
05600 (HIDE D (GETCONTEXT 1 N)) D)
05700 (DATUMIZE (ARG 1))) )
05800
05900
06000 (DEFUN ACTUALIZE N (REVEAL (ARG 1) (GETCONTEXT 1 N)) (ARG 1) )
06100
06200
06300 (DEFUN UNACTUALIZE N (HIDE (ARG 1) (GETCONTEXT 1 N)) (ARG 1) ) (DECLARE (UNSPECIAL DATUM) (SPECIAL PAT CON))
06400
06500 (DEFUN REALIZE N
06600 (PROG (DATUM CON PAT)
06700 (SETQ DATUM (ARG 1)
06800 CON (GETCONTEXT 1 N))
06900 (COND ((AND (REVEAL DATUM CON) (SETQ PAT (ITEM DATUM)))
07000 (CEVAL '(CALLDEMONS (/@ . PAT) (/@ . *IF-ADDEDS) (/@ . CON)))) )
07100 (RETURN DATUM) ))
07200
07300
07400 (CDEFUN REALIZE (DATUM "OPTIONAL" (CONTEXT CONTEXT))
07500 "AUX" (PAT)
07600 (COND ((/@ AND (REVEAL (/, DATUM) (/, CONTEXT))
07700 (CSETQ PAT (ITEM (/, DATUM))))
07800 (CALLDEMONS PAT (/@ . *IF-ADDEDS) CONTEXT)) )
07900 DATUM)
08000
08100
08200 (DEFUN UNREALIZE N
08300 (PROG (DATUM CON PAT)
08400 (SETQ DATUM (ARG 1)
08500 CON (GETCONTEXT 1 N))
08600 (COND ((AND (HIDE DATUM CON) (SETQ PAT (ITEM DATUM)))
08700 (CEVAL '(CALLDEMONS (/@ . PAT) (/@ . *IF-REMOVEDS) (/@ . CON)))) )
08800 (RETURN DATUM) ))
08900
09000
09100 (CDEFUN UNREALIZE (DATUM "OPTIONAL" (CONTEXT CONTEXT))
09200 "AUX" (PAT)
09300 (COND ((/@ AND (HIDE (/, DATUM) (/, CONTEXT))
09400 (CSETQ PAT (ITEM (/, DATUM))))
09500 (CALLDEMONS PAT (/@ . *IF-REMOVEDS) CONTEXT)) )
09600 DATUM)
09700
09800 (DECLARE (SPECIAL DATUM) (UNSPECIAL PAT CON)) (DEFUN CALLDEMONS (PAT INDEX CONTEXT)
09900 (CINTERRUPT (LIST 'RUNDAEMONS
10000 PAT
10100 CONTEXT
10200 (SEARCH INDEX PAT NIL (CDR CONTEXT)))))
10300
10400 (CDEFUN RUNDAEMONS ('PAT 'CONTEXT 'METS)
10500 (ALLOW T)
10600 (/: TLP)
10700 (COND (METS (INVOKE (NXTMET) PAT) (GO 'TLP))))
10800
10900 (DEFUN NXTMET FEXPR (L)
11000 (PROG2 (SETQ L (CDR (VLOC 'METS))) (CAAR L) (RPLACA L (CDAR L))))
00100 (DEFUN REVEAL (DATUM CON)
00200 (PROG (CM STATUS CMARKERS CFRAMES PATTERN CNUM CFRAME NEW TYPE NUM)
00300 (PI-OFF)
00400 (SETQ CMARKERS (ANALYZE DATUM)
00500 CFRAMES (SETQ CON (CDR CON))
00600 CM (ADDCFRAME (SETQ CFRAME (CAR CON)) CMARKERS)
00700 CNUM (CADR CFRAME)
00800 STATUS (CADR CM))
00900 (RPLACA (CDR CM) '/+)
01000 (COND (STATUS (PI-ON) (RETURN NIL))
01100 ((AND PATTERN NEW (NULL (CDDR CMARKERS)))
01200 (INDEX DATUM PATTERN (GET TYPE '*INDEX))) )
01300 (SETQ CMARKERS (CDDR CMARKERS) CFRAMES (CDR CFRAMES))
01400 LOOP (COND ((SETQ CM (MFINTERSECT))
01500 (COND ((SETQ NUM (INVISIBLE (CADR CM) CON))
01600 (COND ((EQUAL CNUM NUM)
01700 (SETQ NEW NIL)
01800 (RPLACA (CDR CM) (OR (DELETE CNUM (CADR CM) 1) '/+))) ))
01900 ((SETQ STATUS T)) )
02000 (SETQ CMARKERS (CDR CMARKERS) CFRAMES (CDR CFRAMES))
02100 (GO LOOP))
02200 (NEW (RPLACD (CDR CFRAME) (CONS DATUM (CDDR CFRAME)))) )
02300 (PI-ON)
02400 (RETURN (NOT STATUS)) ))
02500
02600
02700 (DEFUN HIDE (DATUM CON)
02800 (PROG (PATTERN CFRAMES CMARKERS CNUM STATUS NUM TYPE REM OLD CFRAME CM)
02900 (SETQ CFRAMES (SETQ CON (CDR CON))
03000 CMARKERS (ANALYZE DATUM)
03100 CNUM (CADAR CON))
03200 (PI-OFF)
03300 (COND ((SETQ CM (FINDCFRAME (SETQ CFRAME (CAR CFRAMES))
03400 (CDR CMARKERS)))
03500 (SETQ STATUS (CADR CM) OLD T)
03600 (COND ((CDDR CM)
03700 (RPLACA (CDR CM) NIL))
03800 ((SETQ REM T)
03900 (DELQ CM CMARKERS 1)
04000 (AND PATTERN
04100 (NULL (CDR CMARKERS))
04200 (UNINDEX DATUM PATTERN (GET TYPE '*INDEX) (EQ TYPE 'ITEM)))) )) )
04300 (SETQ CMARKERS (CDR CMARKERS))
04400 LOOP (COND ((SETQ CM (MFINTERSECT))
04500 (COND ((SETQ NUM (INVISIBLE (CADR CM) CON))
04600 (COND (REM (SETQ REM (NOT (EQUAL CNUM NUM))))
04700 ((OR OLD (SETQ OLD (EQUAL CNUM NUM)))) ))
04800 ((SETQ REM NIL STATUS T)
04900 (CANCEL CM CNUM)) )
05000 (SETQ CMARKERS (CDR CMARKERS) CFRAMES (CDR CFRAMES))
05100 (GO LOOP))
05200 (REM
05300 (RPLACD (CDR CFRAME) (DELQ DATUM (CDDR CFRAME) 1)))
05400 ((AND STATUS (NOT OLD))
05500 (RPLACD (CDR CFRAME) (CONS DATUM (CDDR CFRAME)))) )
05600 (PI-ON)
05700 (RETURN STATUS) )) (DEFUN ADDCFRAME (CFRAME CMARKERS)
05800 (PROG (N)
05900 (SETQ N (CADR CFRAME))
06000 LOOP (COND ((OR (NULL (CDR CMARKERS)) (LESSP (CAADR CMARKERS) N))
06100 (RPLACD CMARKERS (CONS (LIST N NIL) (CDR CMARKERS)))
06200 (SETQ NEW T))
06300 ((EQ N (CAADR CMARKERS)))
06400 (T (SETQ CMARKERS (CDR CMARKERS)) (GO LOOP)) )
06500 (RETURN (CADR CMARKERS)) ))
06600
06700
06800
06900 (DEFUN FINDCFRAME (CFRAME CMARKERS)
07000 (PROG (NF NM)
07100 (SETQ NF (CADR CFRAME))
07200 LOOP (COND ((NULL CMARKERS) (RETURN NIL))
07300 ((> NF (SETQ NM (CAAR CMARKERS)))
07400 (RETURN NIL))
07500 ((> NM NF)
07600 (SETQ CMARKERS (CDR CMARKERS))
07700 (GO LOOP))
07800 ((RETURN (CAR CMARKERS))) ) ))
07900
08000
08100 (DEFUN CANCEL (CM NUM)
08200 (RPLACA (CDR CM) (MERGEN NUM (CADR CM))) )
08300
08400
08500 (DEFUN MERGEN (N NL)
08600 (COND ((ATOM NL) (LIST N))
08700 ((> N (CAR NL)) (CONS N NL))
08800 ((RPLACD NL (MERGEN N (CDR NL)))) )) (DEFUN DPUTCF (DATUM PROPERTY INDICATOR CFRAME)
08900 (PROG (PATTERN TYPE CM TAIL NEW)
09000 (PI-OFF)
09100 (SETQ TAIL (ANALYZE DATUM)
09200 CM (ADDCFRAME CFRAME TAIL))
09300 (COND (NEW
09400 (RPLACD (CDR CFRAME) (CONS DATUM (CDDR CFRAME)))
09500 (AND PATTERN (NULL (CDDR TAIL)) (INDEX DATUM PATTERN (GET TYPE '*INDEX)))) )
09600 (PI-ON)
09700 (RETURN (DPUT1 CM PROPERTY INDICATOR)) ))
09800
09900
10000 (DEFUN DGETCF (DATUM INDICATOR CFRAME)
10100 (ASSQ INDICATOR (FINDCFRAME CFRAME (CDR (CMARKERS DATUM)))) )
10200
10300
10400 (DEFUN DREMCF (DATUM INDICATOR CFRAME)
10500 (PROG (CMARKERS PATTERN TYPE CM PAIR)
10600 (SETQ CMARKERS (ANALYZE DATUM)
10700 CM (FINDCFRAME CFRAME (CDR CMARKERS)))
10800 (COND ((AND CM (SETQ PAIR (ASSQ INDICATOR (CDDR CM))))
10900 (PI-OFF)
11000 (DELQ PAIR (CDR CM) 1)
11100 (COND ((NOT (OR (CADR CM) (CDDR CM)))
11200 (DELQ CM CMARKERS 1)
11300 (DELQ DATUM CFRAME 1)) )
11400 (COND ((AND PATTERN
11500 (NULL (CDR CMARKERS)))
11600 (UNINDEX DATUM PATTERN (GET TYPE '*INDEX) (EQ TYPE 'ITEM))) )
11700 (PI-ON)
11800 (RETURN PAIR)) ) ))
00100 (DEFUN DPUT N
00200 (DPUTCF (ARG 1) (ARG 2) (ARG 3) (CADR (GETCONTEXT 3 N))) )
00300
00400
00500 (DEFUN DGET N
00600 ((LAMBDA (CONTEXT)
00700 (DGET1 (CDR (CMARKERS (ARG 1))) (ARG 2) (CDR CONTEXT) NIL))
00800 (GETCONTEXT 2 N)) )
00900
01000
01100 (DEFUN DREM N
01200 (DREM1 (ARG 1) (ARG 2) (CDR (GETCONTEXT 2 N)) NIL) ) (DEFUN DPUT+ N
01300 ((LAMBDA (CM)
01400 (COND (CM (DPUT1 CM (ARG 2) (ARG 3)))
01500 ((CERR ABSENT DATUM)) ))
01600 (REALITY (ARG 1) (GETCONTEXT 3 N))) )
01700
01800
01900 (DEFUN DGET+ N
02000 (DGET1 (CDR (CMARKERS (ARG 1))) (ARG 2) (CDR (GETCONTEXT 2 N)) T) )
02100
02200
02300 (DEFUN DREM+ N
02400 (DREM1 (ARG 1) (ARG 2) (CDR (GETCONTEXT 2 N)) T) )
02500
02600
02700
02800
00100 (DEFUN DPUT1 (CM PROPERTY INDICATOR)
00200 (PROG (PAIR)
00300 (COND ((SETQ PAIR (ASSQ INDICATOR (CDDR CM)))
00400 (RPLACA (CDR PAIR) PROPERTY))
00500 ((RPLACD (CDR CM)
00600 (CONS (SETQ PAIR (LIST INDICATOR PROPERTY))
00700 (CDDR CM)))) )
00800 (RETURN PAIR) ))
00900
01000
01100 (DEFUN DGET1 (CMARKERS INDICATOR CFRAMES SIGN)
01200 (PROG (PAIR CM CON)
01300 (SETQ CON CFRAMES)
01400 LOOP (COND ((NULL (SETQ CM (MFINTERSECT)))
01500 (RETURN NIL))
01600 ((AND SIGN (INVISIBLE (CADR CM) CON)))
01700 ((SETQ PAIR (ASSQ INDICATOR (CDDR CM)))
01800 (RETURN PAIR)) )
01900 (SETQ CMARKERS (CDR CMARKERS)
02000 CFRAMES (CDR CFRAMES))
02100 (GO LOOP)) )
02200
02300
02400 (DEFUN DREM1 (DATUM INDICATOR CFRAMES SIGN)
02500 (PROG (PAIR CMARKERS TAIL PATTERN TYPE CM CON)
02600 (SETQ CON CFRAMES
02700 CMARKERS (CDR (SETQ TAIL (ANALYZE DATUM))))
02800 LOOP (COND ((NULL (SETQ CM (MFINTERSECT)))
02900 (RETURN NIL))
03000 ((AND SIGN (INVISIBLE (CADR CM) CON)))
03100 ((SETQ PAIR (ASSQ INDICATOR (CDDR CM)))
03200 (PI-OFF)
03300 (DELQ PAIR (CDR CM))
03400 (COND ((NOT (OR (CADR CM) (CDDR CM)))
03500 (DELQ CM TAIL)
03600 (DELQ DATUM (CAR CFRAMES))) )
03700 (COND ((AND PATTERN (NULL (CDR TAIL)))
03800 (UNINDEX DATUM PATTERN (GET TYPE '*INDEX) (EQ TYPE 'ITEM))) )
03900 (PI-ON)
04000 (RETURN PAIR)) )
04100 (SETQ CMARKERS (CDR CMARKERS)
04200 CFRAMES (CDR CFRAMES))
04300 (GO LOOP) ))
04400
00100 (DEFUN MENTIONERS N
00200 (PROG (CFRAMES CMARKERS MENTIONERS SIGN CM CON)
00300 (COND ((< N 1) (TFA)) )
00400 (SETQ CFRAMES (CDR (COND ((< N 3) (/, CONTEXT))
00500 ((= N 3) (ARG 3))
00600 ((TMA)) ))
00700 SIGN (COND ((> N 1) (ARG 2)) )
00800 CMARKERS (CDR (CMARKERS (ARG 1)))
00900 CON CFRAMES)
01000 LOOP (COND ((SETQ CM (MFINTERSECT))
01100 (OR (AND SIGN (INVISIBLE (CADR CM) CON))
01200 (SETQ MENTIONERS (CONS (CAR CFRAMES) MENTIONERS)))
01300 (SETQ CFRAMES (CDR CFRAMES)
01400 CMARKERS (CDR CMARKERS))
01500 (GO LOOP)) )
01600 (RETURN (REVERSE MENTIONERS)) ))
01700
01800
01900 (DECLARE (UNSPECIAL DATUM))
02000
02100 (DEFUN C-MARKER (DATUM CFRAME)
02200 (FINDCFRAME CFRAME (CDR (CMARKERS DATUM))) )
02300
02400 (DECLARE (SPECIAL DATUM)) (DEFUN MFINTERSECT ()
02500 (PROG (NM NF CM)
02600 ADVANCE
02700 (COND ((AND CMARKERS CFRAMES)
02800 (SETQ NF (CADAR CFRAMES)
02900 CM (CAR CMARKERS)
03000 NM (CAR CM)))
03100 ((RETURN NIL)) )
03200 TEST (COND ((> NF NM)
03300 (OR (SETQ CFRAMES (CDR CFRAMES))
03400 (RETURN NIL))
03500 (SETQ NF (CADAR CFRAMES))
03600 (GO TEST))
03700 ((> NM NF)
03800 (OR (SETQ CMARKERS (CDR CMARKERS))
03900 (RETURN NIL))
04000 (SETQ CM (CAR CMARKERS)
04100 NM (CAR CM))
04200 (GO TEST))
04300 ((RETURN CM)) ) ))
04400
04500 (DECLARE (UNSPECIAL CMARKERS))
04600
04700
04800 (DEFUN INVISIBLE (CNUMS CFRAMES)
04900 (AND (NOT (EQ CNUMS '/+))
05000 (OR (NULL CNUMS)
05100 (PROG (NC NF)
05200 (SETQ NC (CAR CNUMS))
05300 LOOP (COND (CFRAMES
05400 (SETQ NF (CADAR CFRAMES) CFRAMES (CDR CFRAMES)))
05500 ((RETURN NIL)) )
05600 TEST (COND ((> NF NC) (GO LOOP))
05700 ((> NC NF)
05800 (OR (SETQ CNUMS (CDR CNUMS)) (RETURN NIL))
05900 (SETQ NC (CAR CNUMS))
06000 (GO TEST))
06100 ((RETURN NC)) ) ))) )
06200
06300 (DECLARE (UNSPECIAL CFRAMES))
06400
06500
06600 (DEFUN GETCONTEXT (K N)
06700 (COND ((< N K) (TFA))
06800 ((= N K) (/, CONTEXT))
06900 ((= N (SETQ K (ADD1 K))) (ARG K))
07000 ((TMA)) )) (DECLARE (UNSPECIAL PATTERN))
07100
07200 (DEFUN ISEARCH (INDEX PATTERN ITEM)
07300 (APPLY 'APPEND (CDR (ISEARCH1 INDEX PATTERN ITEM))) )
07400
07500
07600 (DEFUN ISEARCH1 (INDEX PATTERN ITEM)
07700 (PROG (ASCAR ASCDR)
07800 (COND ((NULL INDEX) (RETURN (LIST 0)))
07900 ((EQ (CAR INDEX) '*LIST)
08000 (RETURN (CONS (CADDR INDEX) (LIST (CDDDR INDEX)))))
08100 ((EQ (CAR INDEX) '*INDEX))
08200 (T (BREAK BAD-STRUCTURE-INDEX--ISEARCH T)) )
08300 (RETURN (COND ((OR
08400 (ZEROP (CAR (SETQ ASCAR
08500 (ASEARCH (CADDR INDEX) (CAR PATTERN) ITEM))))
08600 (NULL (CDR PATTERN))
08700 (> (CAR (SETQ ASCDR
08800 (ASEARCH (CDDDR INDEX) (CDR PATTERN) ITEM)))
08900 (CAR ASCAR)))
09000 ASCAR)
09100 (ASCDR) )) ))
09200
09300
09400 (DEFUN ASEARCH (SUBINDEX ELEMENT ITEM)
09500 (PROG (INDICATOR ASSOCIATION CLLIST VLIST)
09600 (COND ((EQ (SETQ INDICATOR (ATOMIZE ELEMENT)) '*VARIABLE)
09700 (RETURN (LIST 10000))) )
09800 (SETQ CLLIST
09900 (COND ((EQ INDICATOR '*STRUCTURE)
10000 (ISEARCH1 (CAR SUBINDEX) ELEMENT ITEM))
10100 ((SETQ ASSOCIATION (ASSQ1 INDICATOR (CDR SUBINDEX)))
10200 (CONS (CADR ASSOCIATION) (LIST (CDDR ASSOCIATION))))
10300 ((LIST 0)) ))
10400 (COND ((AND (NOT ITEM)
10500 (SETQ ASSOCIATION (ASSQ '*VARIABLE (CDR SUBINDEX)))
10600 (SETQ VLIST (CDDR ASSOCIATION)))
10700 (RPLACA CLLIST (/+ (CAR CLLIST) (CADR ASSOCIATION)))
10800 (RPLACD CLLIST (CONS VLIST (CDR CLLIST)))) )
10900 (RETURN CLLIST) ))
11000
11100
11200 (DEFUN ASSQ1 (IND ALIST)
11300 (COND ((NUMBERP IND) (ASSOC IND ALIST))
11400 ((ASSQ IND ALIST)) )) (DECLARE (SPECIAL THING PFORM INDEX))
11500
11600 (DEFUN INDEX (THING PATTERN INDEX)
11700 (PROG (NUM THINGS PFORM)
11800 (COND ((NULL INDEX) (BREAK BAD-INDEX--INDEX T))
11900 ((EQ (CAR INDEX) '*LIST)
12000 (COND ((EQUAL (SETQ NUM (ADD1 (CADDR INDEX)))
12100 *INDEXTHRESHOLD)
12200 (RPLACA INDEX '*INDEX)
12300 (SETQ THINGS (CDDDR INDEX) PFORM (CADR INDEX))
12400 (RPLACD (CDR INDEX) (LIST (LIST NIL) NIL))
12500 (MAPC
12600 (/!" LAMBDA (THING)
12700 (INDEX THING (/@ . PFORM) INDEX))
12800 THINGS))
12900 (T (RPLACD (CDR INDEX)
13000 (CONS NUM
13100 (CONS THING (CDDDR INDEX))))
13200 (RETURN THING)) ))
13300 ((EQ (CAR INDEX) '*INDEX)
13400 (SETQ PFORM (CADR INDEX)))
13500 ((BREAK BAD-INDEX--INDEX T)) )
13600 (INDEX1 THING (CAR PATTERN) (CADDR INDEX) 'CAR PFORM)
13700 (AND (CDR PATTERN)
13800 (INDEX1 THING (CDR PATTERN) (CDDDR INDEX) 'CDR PFORM))
13900 (RETURN THING) ))
14000
14100 (DECLARE (UNSPECIAL PFORM INDEX))
14200
14300
14400 (DEFUN UNINDEX (THING PATTERN INDEX ITEM)
14500 (COND ((NULL INDEX) (BREAK BAD-INDEX--UNINDEX T))
14600 ((EQ (CAR INDEX) '*LIST)
14700 (RPLACD (CDR INDEX)
14800 (CONS (SUB1 (CADDR INDEX))
14900 (DELTHING THING (CDDDR INDEX) ITEM)))
15000 THING)
15100 ((EQ (CAR INDEX) '*INDEX)
15200 (UNINDEX1 THING (CAR PATTERN) (CADDR INDEX) ITEM)
15300 (AND (CDR PATTERN)
15400 (UNINDEX1 THING (CDR PATTERN) (CDDDR INDEX) ITEM))
15500 THING)
15600 ((BREAK BAD-INDEX--UNINDEX T)) ))
15700
15800 (DECLARE (UNSPECIAL THING))
15900
16000
16100 (DEFUN INDEX1 (THING ELEMENT SUBINDEX POS PFORM)
16200 (PROG (INDICATOR ASSOCIATION)
16300 (COND ((EQ (SETQ INDICATOR (ATOMIZE ELEMENT)) '*STRUCTURE)
16400 (COND ((NULL (CAR SUBINDEX))
16500 (RPLACA SUBINDEX (LIST '*LIST (LIST POS PFORM) 0))) )
16600 (INDEX THING ELEMENT (CAR SUBINDEX)))
16700 ((SETQ ASSOCIATION (ASSQ1 INDICATOR (CDR SUBINDEX)))
16800 (RPLACD ASSOCIATION
16900 (CONS (ADD1 (CADR ASSOCIATION))
17000 (CONS THING (CDDR ASSOCIATION)))))
17100 (T (RPLACD SUBINDEX
17200 (CONS (LIST INDICATOR 1 THING)
17300 (CDR SUBINDEX)))) ) ))
17400
17500
17600 (DEFUN UNINDEX1 (THING ELEMENT SUBINDEX ITEM)
17700 (PROG (ASSOCIATION INDICATOR NUM)
17800 (SETQ INDICATOR (ATOMIZE ELEMENT))
17900 (COND ((EQ INDICATOR '*STRUCTURE)
18000 (UNINDEX THING ELEMENT (CAR SUBINDEX) ITEM))
18100 ((SETQ ASSOCIATION (ASSQ1 INDICATOR (CDR SUBINDEX)))
18200 (COND ((ZEROP (SETQ NUM (SUB1 (CADR ASSOCIATION))))
18300 (DELQ ASSOCIATION SUBINDEX))
18400 (T (RPLACD ASSOCIATION
18500 (CONS NUM
18600 (DELTHING THING (CDDR ASSOCIATION) ITEM)))) )) ) )) (DECLARE (SPECIAL PATTERN))
18700
18800 (DEFUN ANALYZE (X)
18900 (COND ((NULL X)
19000 (CERR MEANINGLESS DATUM -- ANALYZE))
19100 ((ATOM X)
19200 (ANALYZE (GET X 'DATUM)))
19300 ((EQ (CAR X) '*CLOSURE)
19400 (PROG2 (ANALYZE (CADR X)) (CDDR X) (SETQ DATUM X)))
19500 ((EQ (CAR X) '*OBJECT)
19600 (SETQ PATTERN NIL TYPE 'OBJECT)
19700 (CDR X))
19800 ((ATOM (SETQ TYPE (CAR X)))
19900 (SETQ PATTERN (CADDR X))
20000 (AND (CADR X) (SETQ DATUM (CADR X)))
20100 (CDDDR X))
20200 (T (SETQ PATTERN (CAR X) TYPE 'ITEM)
20300 X) ))
20400
20500 (DECLARE (UNSPECIAL PATTERN))
20600
20700 (DEFUN CMARKERS (DATUM)
20800 (COND ((NULL DATUM)
20900 (CERR MEANINGLESS DATUM -- CMARKERS))
21000 ((ATOM DATUM)
21100 (CMARKERS (GET DATUM 'DATUM)))
21200 ((EQ (CAR DATUM) '*CLOSURE)
21300 (CDDR DATUM))
21400 ((EQ (CAR DATUM) '*OBJECT)
21500 (CDR DATUM))
21600 ((ATOM (CAR DATUM))
21700 (CDDDR DATUM))
21800 (DATUM) ))
21900
22000
22100 (DEFUN PATTERN (DATUM)
22200 (COND ((NULL DATUM)
22300 (CERR MEANINGLESS DATUM -- PATTERN))
22400 ((ATOM DATUM)
22500 (PATTERN (GET DATUM 'DATUM)))
22600 ((EQ (CAR DATUM) '*CLOSURE)
22700 (PATTERN (CADR DATUM)))
22800 ((ATOM (CAR DATUM))
22900 (CADDR DATUM))
23000 ((CAR DATUM)) ))
23100
23200
23300 (DEFUN NTH (EXP N)
23400 (COND ((= N 1) (CAR EXP))
23500 ((NTH (CDR EXP) (SUB1 N))) )) (DEFUN DELTHING (THING LIST ITEM)
23600 (COND (ITEM
23700 (DELITEM (ITEM THING) LIST))
23800 ((DELQ THING LIST 1)) ))
23900
24000
24100 (DEFUN DELITEM (EXP LIST)
24200 (COND ((NULL LIST) NIL)
24300 ((EQUAL EXP (ITEM (CAR LIST)))
24400 (CDR LIST))
24500 (T (RPLACD LIST (DELITEM EXP (CDR LIST)))) ))
24600
24700
24800 (DEFUN MEMCAR (EXP LIST)
24900 (COND ((NULL LIST) NIL)
25000 ((EQUAL EXP (ITEM (CAR LIST)))
25100 LIST)
25200 (T (MEMCAR EXP (CDR LIST))) ))
25300
25400
25500 (DEFUN ITEM (DATUM)
25600 (COND ((NULL DATUM) (CERR MEANINGLESS DATUM))
25700 ((ATOM DATUM) (ITEM (GET DATUM 'DATUM)))
25800 (((LAMBDA (PAT) (AND (NOT (ATOM PAT)) PAT)) (CAR DATUM))) ))
25900
26000 (DEFUN DATUMIZE (THING) (COND ((ATOM THING) THING) ((DATUM THING)) ))
26100
26200 (DEFUN ATOMIZE (ELEMENT)
26300 (COND ((ATOM ELEMENT) ELEMENT)
26400 ((ACTOR (CAR ELEMENT)) '*VARIABLE)
26500 (T '*STRUCTURE) ))
00100 (DEFUN PUSH-CONTEXT N
00200 (CONS '*CONTEXT (CONS (CFRAME) (CDR (GETCONTEXT 0 N)))))
00300
00400
00500 (DEFUN POP-CONTEXT N
00600 (CONS '*CONTEXT (CDDR (GETCONTEXT 0 N))))
00700
00800
00900 (DECLARE (UNSPECIAL CFRAMES))
01000
01100 (DEFUN NEW-CONTEXT (CFRAMES)
01200 (COND ((ORDERED CFRAMES)
01300 (CONS '*CONTEXT CFRAMES))
01400 ((CERR UNORDERED CONTEXT)) ))
01500
01600 (DECLARE (SPECIAL CFRAMES))
01700
01800
01900 (DEFUN SPLICE (CONTEXT)
02000 (RPLACD (CDR CONTEXT)
02100 (CONS (CFRAME (NEWCNUM (CADR (CADDR CONTEXT))
02200 (CADADR CONTEXT)))
02300 (CDDR CONTEXT)))
02400 CONTEXT)
02500
02600
02700 (DECLARE (SPECIAL EXPR))
02800
02900 (DEFUN IN-CONTEXT (CONTEXT EXPR)
03000 (CEVAL '((CLAMBDA (CONTEXT) (CEVAL (/@ . EXPR))) (/@ .CONTEXT))) )
03100 (DECLARE (UNSPECIAL EXPR))
03200
03300
03400 (CDEFUN IN-CONTEXT (CONTEXT EXPR)
03500 (CEVAL EXPR) )
03600
03700
03800 (DEFUN PATH (C) (CONS '*CONTEXT (MAPCAR 'CADR (CDR C))) ) (DEFUN CFRAME K
03900 ((LAMBDA (NFRAME)
04000 (COND ((AND (= NUMACT NUMCON)(= (GCCON) NUMCON))
04100 (CERR TOO MANY CONTEXT-FRAMES)) )
04200 (PI-OFF)
04300 (STORE (FRAMES NUMACT) NFRAME)
04400 (STORE (RFRAMES NUMACT) (CDR NFRAME))
04500 (SETQ NUMACT (ADD1 NUMACT))
04600 (PI-ON)
04700 NFRAME)
04800 (LIST '*CFRAME (COND ((ZEROP K) (SETQ *CNUM (PLUS INCCON *CNUM)))
04900 (T (ARG 1)) ))) )
05000
05100
05200 (DEFUN ORDERED (CLIST)
05300 (OR (NULL CLIST)
05400 (PROG NIL
05500 LOOP (COND ((CDR CLIST)
05600 (OR (< (CADADR CLIST) (CADAR CLIST))
05700 (RETURN NIL))
05800 (SETQ CLIST (CDR CLIST))
05900 (GO LOOP)) )
06000 (RETURN T))) )
06100
06200
06300 (DEFUN NEWCNUM (LOW HIGH)
06400 (PROG (N INC INUSE)
06500 (SETQ N (// (PLUS LOW HIGH) 2)
06600 INUSE (CNUMSINUSE LOW HIGH)
06700 INC 1)
06800 LOOP (COND ((GREATERP HIGH N LOW)
06900 (COND ((MEMBER N INUSE)
07000 (SETQ N (PLUS N INC)
07100 INC (DIFFERENCE 0 (ADD1 INC)))
07200 (GO LOOP))
07300 ((RETURN N)) ))
07400 ((CERR NO NEW CNUM BETWEEN (* LOW) AND (* HIGH))) ) ))
07500
07600
07700 (DEFUN CNUMSINUSE (LOW HIGH)
07800 (PROG (I NUMS J N)
07900 (SETQ I 0 J (SUB1 NUMACT))
08000 LOOP (COND ((> I J) (RETURN NUMS))
08100 ((OR (> LOW (SETQ N (CAR (RFRAMES I))))
08200 (> N HIGH)))
08300 ((SETQ NUMS (CONS N NUMS))) )
08400 (SETQ I (ADD1 I))
08500 (GO LOOP) )) (DEFUN *GCCON () (PROG (M N)
08600 (SETQ N 0 M NUMACT)
08700
08800 NGCLP
08900 (COND ((= M N) (RETURN N))
09000 ((EQ (CDR (FRAMES N)) (RFRAMES N))
09100 (SETQ N (ADD1 N)) (GO NGCLP)))
09200
09300 (FLUSH (RFRAMES N))
09400 (STORE (RFRAMES N) 0)
09500
09600 MGCLP
09700 (SETQ M (SUB1 M))
09800 (COND ((= M N) (RETURN N))
09900 ((EQ (CDR (FRAMES M)) (RFRAMES M)) (GO EXCH)))
10000 (FLUSH (RFRAMES M))
10100 (STORE (RFRAMES M) 0)
10200 (GO MGCLP)
10300
10400 EXCH
10500 (STORE (FRAMES N) (FRAMES M))
10600 (STORE (RFRAMES N) (RFRAMES M))
10700 (STORE (RFRAMES M) 0)
10800 (GO NGCLP)))
10900
11000
11100 (DEFUN GCCON FEXPR (L)
11200 (PI-OFF)
11300 (SETQ L (SETQ NUMACT (*GCCON)))
11400 (PI-ON)
11500 L)
11600
11700 (DECLARE (SPECIAL PATTERN))
11800
11900 (DEFUN FLUSH (CFRAME)
12000 (PROG (THING THINGS N PATTERN TYPE CMARKERS)
12100 (SETQ THINGS (CDR CFRAME) N (CAR CFRAME))
12200 LOOP (COND ((NULL THINGS)
12300 (RETURN NIL)) )
12400 (COND ((AND (REMCFRAME N
12500 (SETQ CMARKERS (ANALYZE (SETQ THING (CAR THINGS)))))
12600 PATTERN
12700 (NULL (CDR CMARKERS)))
12800 (UNINDEX THING
12900 PATTERN
13000 (GET TYPE '*INDEX)
13100 (EQ TYPE 'ITEM))) )
13200 (SETQ THINGS (CDR THINGS))
13300 (GO LOOP) ))
13400
13500 (DECLARE (UNSPECIAL PATTERN))
00100 (DEFUN REMCFRAME (N CMARKERS)
00200 (PROG (M CM)
00300 LOOP1 (COND ((NULL (CDR CMARKERS))
00400 (RETURN NIL))
00500 ((= N (SETQ M (CAADR CMARKERS)))
00600 (RPLACD CMARKERS (CDDR CMARKERS))
00700 (RETURN T))
00800 ((> N M)
00900 (SETQ CMARKERS (CDR CMARKERS))
01000 (GO LOOP1)) )
01100 LOOP2 (SETQ CMARKERS (CDR CMARKERS))
01200 (COND ((NULL CMARKERS) (RETURN NIL))
01300 ((ATOM (CADR (SETQ CM (CAR CMARKERS))))
01400 (AND (MEMBER N (CADR CM))
01500 (RPLACA (CDR CM)
01600 (OR (DELETE N (CADR CM) 1) '/+)))) )
01700 (GO LOOP2) ))
01800
01900
02000 (DEFUN /!" FEXPR (L) (/!"1 L))
02100
02200
02300 (DEFUN /!"1 (L)
02400 (COND ((ATOM L) L)
02500 ((EQ (CAR L) '/@) (EVAL (CDR L)))
02600 ((EQ (CAR L) '/,) (IVAL (CADR L) '*TOP))
02700 ((ATOM (CAR L)) (CONS (CAR L) (/!"1 (CDR L))))
02800 ((EQ (CAAR L) '/!/@) (APPEND (EVAL (CDAR L))(/!"1 (CDR L))))
02900 (T (CONS (/!/"1 (CAR L)) (/!"1 (CDR L))))) )